perm filename PRED4.FAI[SYS,HE]1 blob sn#009297 filedate 1972-12-06 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00014 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00003 00002	TITLE WINGS  -  THE WINGED EDGE SUBROUTINES  -  JULY 1972.
 00005 00003	DYNAMIC FREE STORAGE ROUTINES.
 00007 00004	RELEASE A BLOCK  -  RELBLK(E)  -  E/ SIZE,,0
 00009 00005	 BFEV MAKES AND KILLS.
 00011 00006	DEFINE MKQ $(FACE,F){
 00012 00007	BFEV KILL OPERATIONS.
 00013 00008	SUBR KLBFEV
 00014 00009	WING MAKE LINKS.
 00016 00010	 ORIENTED WING FETCH OPERATIONS.
 00017 00011	 ORIENTED WING FETCH OPERATIONS.
 00019 00012	 BODY FETCHER - GET THE BODY OF Q.
 00021 00013	SUBR(MKLOCOR)
 00022 00014	ATTACH B1 TO B2, B1 BECOMES A SUBPART OF B2.
 00024 ENDMK
⊗;
TITLE WINGS  -  THE WINGED EDGE SUBROUTINES  -  JULY 1972.
COMMENT /     - 28 PRIMITIVES -

0. DYNAMIC FREE STORAGE...............................2 & 3.
	ADDR ← GETBLK(SIZE);
	RELBLK(ADDR);

1. BFEV MAKE & KILL OPERATIONS........................4 & 5.
	BNEW ← MKB(B);	 KLB(BNEW);
	FNEW ← MKF(B);	 KLF(B,FNEW);
	ENEW ← MKE(B);	 KLE(B,ENEW);
	VNEW ← MKV(B);	 KLV(B,VNEW);
	BNEW ← MKBFV;	 KLBFEV(Q);

2. WING MAKE LINK OPERATIONS..............................6.
	NCW.(Q,E);	PCW.(Q,E);
	NCCW.(Q,E);	PCCW.(Q,E);

3. ORIENTED WING FETCH & STORE OPERATIONS.............7 & 8.
	E ← ECW(E,Q);	ECW.(Q,E,X);
	E ← ECCW(E,Q);	ECCW.(Q,E,X);
	Q ← OTHER(E,Q);	OTHER.(Q,E,X);

4. BFV FETCH OPERATIONS..............................9 & 10.
	B ← BODY(Q);	 B0 ← MKPARTS(B0);
	F ← FCW(E,V);	 F ← FCCW(E,V);
	V ← VCW(E,F);	 V ← VCCW(E,F);
/

	INTERN WORLD↔WORLD: 0
;DYNAMIC FREE STORAGE ROUTINES.
 	EXTERN CORGET;
	NIL←777777
	INTERN CORSIZ↔CORSIZ: 0
	SAVP1: .+1
	AVAIL: NIL
; ADDR ← GETBLK(SIZE);
SUBR GETBLK;(SIZE)
BEGIN	GETBLK
	ACCUMULATORS{PTR,SIZ,P1,P2,N}

; FETCH THE ARGUMENTS.
	LAC N,ARG1↔ADDM N,CORSIZ
	LAC P1,SAVP1

; SCAN AVAIL LIST.
L1:	CDR P2,(P1);
	CAIN P2,NIL;

; WHEN THERE'S NO ROOM, GET A BIG BLOCK FROM SAIL.
	GO[NIM SIZ,=4090↔CALL CORGET
	GO[FATAL(GETBLK)];
	DIP SIZ,(PTR)
	CALL RELBLK,PTR;
	LIMZ P1,AVAIL↔LAC N,ARG1↔GO L1]

; IS THIS ONE BIG ENUF ?
	CAR SIZ,(P2)
	CAMGE SIZ,N
	GO[LAC P1,P2↔GO L1]

; CARVE N WORDS OFF THE TOP.
	SUB SIZ,N
	JUMPE SIZ,[CDR(P2)↔DAP(P1)↔LIMZ P1,AVAIL↔GO L2];ALL USED UP.
	DIP SIZ,(P2)
L2:	ADD SIZ, P2
	SETZM (SIZ)
	RET1(SIZ)
	LIT
BEND
;RELEASE A BLOCK  -  RELBLK(E)  -  E/ SIZE,,0
SUBR RELBLK;(ADDR)
BEGIN	RELBLK
	ACCUMULATORS{E,SIZ,P1,P2}
; FETCH ARGUMENTS AND CLEAR THE BLOCK.
	CDR E,ARG1↔CAR SIZ,(E)
	CAIGE SIZ,=4000↔GO[MOVNS SIZ↔ADDM SIZ,CORSIZ↔MOVNS SIZ↔GO .+1]
	SETZM 1(E)↔CAIE SIZ,1↔GO[
	LAC E↔SLAP E↔ADD [XWD 1,2]
	LAC 1,SIZ↔ADD 1,E↔BLT -1(1)↔GO .+1]

; FIND BLOCK'S PLACE IN AVAIL.
	LIMZ P1,AVAIL
L3:	CDR P2,(P1)
	CAMG P2,E
	GO [LAC P1,P2↔ GO L3]

; TRY TO MERGE WITH THE BLOCK ABOVE.
	LAC E↔ ADD SIZ↔ CAME P2;
	GO [DAP P2,(E)↔ GO L4];	NO MERGE - SO ME POINT AT HIM.

; MERGE WITH BLOCK ABOVE.
	CAR(P2)↔ADD SIZ,;	ME BIGGER NOW.
	CDR(P2)↔DAP (E) ;	ME POINT WHERE HE POINTS.
	SETZM(P2)

; TRY TO MERGE WITH THE BLOCK BELOW.
L4:	CAR(P1)↔ADD P1↔CAME E;
	GO[DAP E,(P1)↔DIP SIZ,(E)↔GO L5]

; MERGE WITH BLOCK BELOW.
	CAR(P1)↔ADD SIZ↔DIP (P1);	HIM BIGGER NOW.
	CDR(E)↔DAP(P1);			HIM POINT WHERE I POINT.
	SETZM(E)

L5:	RET1
	LIT
BEND
; BFEV MAKES AND KILLS.
BEGIN	MAKILL
INTERN BTOTAL,FTOTAL,ETOTAL,VTOTAL
	BTOTAL: 0↔FTOTAL: 0↔ETOTAL: 0↔VTOTAL: 0
INTERN BSIZE,FSIZE,ESIZE,VSIZE
	BSIZE:  4+6
	FSIZE:  4+6
	ESIZE:  4+12
	VSIZE:  4+6

; BNEW ← MKB(B0)
SUBR(MKB)
BEGIN	MKB
	B←1 ↔ B0←2
	CALL GETBLK,BSIZE
	ADDI B,3 ↔ MARK B,BBIT
;ATTACH B TO B0, THAT IS B IS A SUB-PART OF B0.
	LAC B0,ARG1↔PART 0,B0↔PART. B,B0↔AOS 5(B0);INCREM PCNT.
	COPAR. 0,B↔LACN 0,B↔PART. 0,B; BNEW HAVE NO PARTS.
	SLAP B,B↔FOR I←1,3<DAC B,I(B)↔>CDR B,B
	EXCH 2 ↔ AOS 2,BTOTAL ↔ SERIA. 2,B ↔ EXCH 2
	RET1
BEND

SUBR(MKBFV)
	CALL MKB,WORLD
	DAC 1,BNEW#
	CALL MKF,BNEW
	CALL MKV,BNEW
	RET0(BNEW)
DEFINE MKQ $(FACE,F){
SUBR(MK$F)
BEGIN	MK$F
	Q←1 ↔ X←2 ↔ B←3
	SAVAC(6)
	CALL GETBLK,F$SIZE
	ADDI 1,3
CAR(1)↔SKIPE↔BUG: HALT
	MARK 1,F$BIT
	AOS F$TOTAL
	LAC B,ARG1
	F$CNT 0,B↔AOS↔F$CNT. 0,B
	N$FACE		X,B
	P$FACE$.	Q,X
	N$FACE$.	Q,B
	P$FACE$.	B,Q
	N$FACE$.	X,Q
	IFIDN<E><F><PBODY. B,Q>
	SETZ↔CAME X,B↔SERIAL 0,X↔AOS↔SERIA. 0,Q
	GETAC(6)
	RET1
BEND}
	MKQ(FACE,F)
	MKQ(ED,E)
	MKQ(VT,V)

;BFEV KILL OPERATIONS.

SUBR(KLB)
BEGIN	KLB
	B←1
	LAC  B,ARG1
	SUBI B,3
	LAC  BSIZE
	DIPZ (B)
	CALL RELBLK,B
	SOS BTOTAL
	RET1
BEND

DEFINE KLQ $(FACE,F){
SUBR(KL$F)
BEGIN	KL$F
	X←2 ↔ Y←B←3
	SAVAC(6)
	LAC  1,ARG1
	N$FACE		X,1
	P$FACE		Y,1
	N$FACE$.	X,Y
	P$FACE$.	Y,X
	SUBI 1,3
	LAC  F$SIZE
	DIPZ (1)
	CALL RELBLK,1
	SOS F$TOTAL
	LAC B,ARG2
	F$CNT 0,B↔SOS↔F$CNT. 0,B
	GETAC(6)
	RET2
BEND}
	KLQ(FACE,F);
	KLQ(ED,E);
	KLQ(VT,V);
BEND
SUBR KLBFEV
BEGIN	KLBFEV
	ACCUMULATORS{B,F,E,V}
	LAC B,ARG1
	SETQ(B,{BODY,B})
L1:	PFACE F,B↔TESTZ F,FBIT↔GO[CALL KLF,B,F↔GO L1]
L2:	PED   E,B↔TESTZ E,EBIT↔GO[CALL KLE,B,E↔GO L2]
L3:	PVT   V,B↔TESTZ V,VBIT↔GO[CALL KLV,B,V↔GO L3]
	CALL KLB,B
	RET1
BEND
;WING MAKE LINKS.
;	NCW.(Q,E);
;	PCW.(Q,E);
;	NCCW.(Q,E);
;	PCCW.(Q,E);

DEFINE WING. $(NAME,N,M,P,DIP,DAP) {
SUBR(NAME)
BEGIN	NAME
	Q←5↔E←6
	SAVAC(6)
	CDR Q,ARG2
	CDR E,ARG1
 	NAME$. Q,E
 	N$FACE 1,E↔M$VT 2,E
	N$FACE 3,Q↔P$VT 4,Q

	CAME 1,3↔	GO[P$FACE 3,Q↔GO L2]
	CAME 2,4↔	GO[N$VT 4,Q↔GO L1]↔	DIP E,5(Q)↔GO L
L1:	CAME 2,4↔	GO DIE↔			DIP E,4(Q)↔GO L

L2:	CAME 1,3↔	GO DIE
	CAME 2,4↔	GO[N$VT 4,Q↔GO L3]↔	DAP E,4(Q)↔GO L
L3:	CAME 2,4↔	GO DIE↔			DAP E,5(Q)↔GO L

DIE:	FATAL(NAME)
L:	GETAC(6)
	RET2
	LIT
BEND}

	WING.(NCW., N,N,P,DIP,DAP)
	WING.(PCW., P,P,N,DAP,DIP)
	WING.(NCCW.,N,P,P,DIP,DAP)
	WING.(PCCW.,P,N,N,DAP,DIP)
; ORIENTED WING FETCH OPERATIONS.
;	E ← ECW(E,X);
;	E ← ECCW(E,X);
;	Q ← OTHER(E,X);

DEFINE OWING (NAME,PCW,NCW,NCCW,PCCW) {
SUBR(NAME)
BEGIN	NAME
	Q←1 ↔ X←2 ↔ E←3
	DAC 2,AC2↔ DAC 3,AC3
	CDR X,ARG1↔CDR E,ARG2
	TEST  X,VBIT
	GO[
	PFACE Q,E↔CAME Q,X↔GO L1↔	PCW  Q,E↔GO L
L1:	NFACE Q,E↔CAME Q,X↔GO DIE↔	NCW  Q,E↔GO L]

	PVT   Q,E↔CAME Q,X↔GO L2↔	NCCW Q,E↔GO L
L2:	NVT   Q,E↔CAME Q,X↔GO DIE↔	PCCW Q,E↔GO L

DIE: 	FATAL(NAME)
L: 	LAC 2,AC2↔ LAC 3,AC3↔ RET2
	LIT
BEND}

	OWING(ECW,  PCW,  NCW,  NCCW,PCCW)
	OWING(ECCW, PCCW, NCCW, PCW, NCW)
	OWING(OTHER,NFACE,PFACE,NVT, PVT)
; ORIENTED WING FETCH OPERATIONS.
;	ECW.(Q,E,X);
;	ECCW.(Q,E,X);
;	OTHER.(Q,E,X);

DEFINE OWING. $(NAME,PCW,NCW,NCCW,PCCW) {
SUBR(NAME)
BEGIN	NAME
	Q←0 ↔ E←X←1
	CDR X,ARG1↔TEST X,VBIT
	GO[
	CDR E,ARG2
	PFACE Q,E↔CAME Q,ARG1↔GO L1
	POP P,-1(P)↔GO PCW$.
L1:	NFACE Q,E↔CAME Q,ARG1↔GO DIE
	POP P,-1(P)↔GO NCW$.]

	CDR E,ARG2
	NVT Q,E↔CAME Q,ARG1↔GO L2
	POP P,-1(P)↔GO NCCW$.
L2:	PVT Q,E↔CAME Q,ARG1↔GO DIE
	POP P,-1(P)↔GO PCCW$.
DIE: 	FATAL(NAME)
	LIT
BEND}

	OWING.(ECW.,  PCW, NCW, NCCW,PCCW)
	OWING.(ECCW., PCCW,NCCW,PCW, NCW)

; OTHER.(Q,E,X)
SUBR(OTHER.)
BEGIN	OTHER.
	Q←1↔ X←2↔ E←3
	DAC AC0↔DAC 1,AC1↔DAC 2,AC2↔DAC 3,AC3
	CDR X,ARG1↔ CDR E,ARG2↔	CDR Q,ARG3
	TEST  X,VBIT
	GO[
	PFACE 0,E↔ CAME X↔ GO L1↔ NFACE. Q,E↔GO L
L1:	NFACE 0,E↔ CAME X↔ GO DIE↔PFACE. Q,E↔GO L]
	NVT   0,E↔ CAME X↔ GO L2↔ PVT.   Q,E↔GO L
L2:	PVT   0,E↔ CAME X↔ GO DIE↔NVT.   Q,E↔GO L
DIE: 	FATAL(OTHER.)
L: 	LAC AC0↔LAC 1,AC1↔LAC 2,AC2↔LAC 3,AC3↔RET3
	LIT
BEND
; BODY FETCHER - GET THE BODY OF Q.
;	B ← BODY(Q).
SUBR(BODI)
SUBR(BODY)
BEGIN	BODY
	Q←1
	CDR Q,ARG1
	TESTZ Q,BBIT
	RET1				;Q'S ALREADY A BODY.
	TESTZ Q,EBIT
L1:	GO [PBODY Q,Q↔RET1]		;Q WAS AN EDGE.
	TESTZ Q,FBIT
	GO [PFACE 0,Q↔PED Q,Q↔JUMPN Q,L1↔GO L2] ;FACE
	TESTZ Q,VBIT
	GO [PVT   0,Q↔PED Q,Q↔JUMPN Q,L1↔GO L2] ;VERTEX
	RET1; Q AIN'T GOT NO BODY.
L2:	RET1(0)		;VERTEX BODY CASE.
	LIT
BEND

; ORIENTED VERTEX-FACE FETCH WRT AN EDGE.
;	V ← VCW(E,F);
;	V ← VCCW(E,F);
;	F ← FCW(E,V);
;	F ← FCCW(E,V);

DEFINE VFETCH $(NAME,FACE,VT,PP,NN){
SUBR(NAME)
BEGIN	NAME
	Q←1 ↔ E←2
	DAC 2,AC2
	CDR E,ARG2
	P$FACE Q,E↔CAME Q,ARG1↔GO L1 ↔PP$VT Q,E↔GO L
L1:	N$FACE Q,E↔CAME Q,ARG1↔GO DIE↔NN$VT Q,E↔GO L
DIE:	FATAL(NAME)
L:	LAC 2,AC2↔RET2↔LIT
BEND}

	VFETCH (VCW,FACE,VT,P,N)
	VFETCH (VCCW,FACE,VT,N,P)
	VFETCH (FCW,VT,FACE,N,P)
	VFETCH (FCCW,VT,FACE,P,N)
SUBR(MKLOCOR)
BEGIN MKLOCOR
	PUSH P,[4+9];LOCOR SIZE.
	PUSHJ P,GETBLK
	ADDI 1,3
	SLIMZ(<1.0>)
	DAC IX(1)
	DAC JY(1)
	DAC KZ(1)
	RET0
BEND

;BLIT(TO,FROM,SIZE)
SUBR(BLIT)
BEGIN	BLIT
	CDR ARG3↔LAC 1,
	SLAP ARG2↔ADD 1,ARG1
	BLT -1(1)↔RET3
BEND

;FETCH THE SUPRA-PART OF A BODY.
SUBR(SUPART)
BEGIN SUPART
	B←1
	CDR B,ARG1
	COPART B,B
	JUMPGE B,.-1
	MOVMS B
	RET1
BEND
;ATTACH B1 TO B2, B1 BECOMES A SUBPART OF B2.
;ATTACH(B1,B2) PRIMITIVE
SUBR(ATT)
BEGIN ATT
	B←1
	ACCUMULATORS{B1,B2}
	CDR B1,ARG2
	CDR B2,ARG1
	PART B,B2
	COPAR. B,B1
	PART. B1,B2
	PCNT 0,B2↔AOS↔PCNT. 0,B2
	RET2
BEND

;DETACH(B) PRIMITIVE
SUBR(DET)
BEGIN DET
	B1←1 ↔ B←2
	PUSH  P,ARG1
	PUSHJ P,SUPART
	PCNT 0,1↔SOS↔PCNT. 0,1
	CDR B,ARG1 ;ME.
	PART 0,B1
	CAMN 0,B↔GO[COPART 0,B↔PART. 0,B1↔RET1]
	LAC B1,0
	COPART 0,B1
	CAME 0,B↔GO[LAC B1,0↔GO .-2]
	COPART 0,B
	COPAR. 0,B1 ;HE POINTS WHERE I USE TO POINT.
	RET1
BEND

;ATTACH(B1,B2) COMMAND.
SUBR(ATTACH)
BEGIN	ATTACH
	LAC 2,ARG1↔TEST 2,BBIT↔RET2
	LAC 2,ARG2↔TEST 2,BBIT↔RET2
	PUSH P,ARG2
	PUSHJ P,DET
	GO ATT
BEND

;DETACH(B) COMMAND.
SUBR(DETACH)
BEGIN	DETACH
	LAC 2,ARG1↔TEST 2,BBIT↔RET1
	PUSH P,ARG1
	PUSHJ P,DET
	POP P,0 ;MY RETURN ADDRESS.
	PUSH P,WORLD
	PUSH P,0 ;KIND OF A PUSHJ.
	GO ATT
BEND
END